home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / UTIL / Alpha 6.5.sit / Tcl / SystemCode / sendURL.tcl < prev    next >
Text File  |  1996-08-15  |  1KB  |  38 lines
  1. # (WTP 7/30/95) Slightly improved 'sendURL'.
  2. # By accepting a text arg, this can now be used to make sendURL 
  3. # hypertext links (useful for "mailto" links in documentation, f'rinstance) 
  4. #===============================================================================
  5. set htmlEventSuiteIDs(MOSS) {WWW!}
  6. proc sendUrl {{text {}}} {
  7.         if {$text == {}} { set text [getSelect] }
  8.          if {[string length $text] == 0} { return }
  9.  
  10.         global htmlEventSuiteIDs browserSig
  11.  
  12.         if {[catch {launchBackApplSigs {MOSS} browserSig}]} {
  13.             getApplSig "Please locate your web browser:" browserSig
  14.         }
  15.         set name [file tail [launchBackAppl $browserSig]]
  16.  
  17.         if {![info exists htmlEventSuiteIDs($browserSig)]} {
  18.                 alertnote "Can't send URLs to this HTML browser"
  19.                 return
  20.         }
  21.         set suite $htmlEventSuiteIDs($browserSig)
  22.  
  23.         AEBuild "'${browserSig}'" $suite {OURL} {----} "ﾒ$textﾓ"
  24.         switchTo $name
  25. }
  26.  
  27.  
  28. proc expandURL {} {
  29.     set pos [getPos]
  30.     set beg [lineStart $pos]
  31.     if {[string length [set whe [search -s -n -f 1 -r 1 -i 1 -m 0 -l [nextLineStart $pos] {[a-zA-Z0-9]+://[a-zA-Z/._0-9~-]+} $beg]]]} {
  32.         if {($pos >= [lindex $whe 0]) && ($pos < [lindex $whe 1])} {
  33.             eval select $whe
  34.             return $whe
  35.         }
  36.     }
  37. }
  38.